home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / PGM_TOOL / PREVIEW / CLP2DLFI / DBSERVER.PAS < prev    next >
Pascal/Delphi Source File  |  1995-11-10  |  41KB  |  1,538 lines
  1. Unit DBFserver;
  2.  
  3. Interface
  4.  
  5. Uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls;
  8.  
  9. Const
  10.   TempExprDBF='\accting\comdat\rocket';  { used by DateDiff() }
  11.     MaxMemoSize=1000;  { set to max memo size you will need }
  12.   MaxTags=15;
  13.   MaxDBFs=60;  { Calc using FILES setting in config.sys, (FILES-20) div 2 }
  14.   MaxBrowseFlds=120;
  15.     sx_DBFCDX=2;
  16.     sx_DBFNTX=1;
  17.     sx_DBFNSX=3;
  18.     sx_READWRITE=0;
  19.     sx_EXCLUSIVE=2;
  20.     { Constants used by sx_Replace() }
  21.   r_integer=1;
  22.   r_long=2;
  23.   r_double=8;
  24.   r_julian=32;
  25.   r_logical=128;
  26.   r_char=1024;
  27.   r_datestr=1056;
  28.   r_memo=3072;
  29.   r_bitmap=4096;
  30.   r_blobfile=8192;
  31.  
  32. Type
  33.   String10=string[11];  { used for common declaration when param passing }
  34.   String20=string[21];
  35.   String30=string[31];
  36.   String40=string[41];
  37.   String80=string[81];
  38.   String135=string[135];
  39.   DBFstruct=Class(TObject)
  40.     fcount:integer;
  41.     fname:array [1..MaxBrowseFlds] of string[11];
  42.     fwidth,fdecs:array [1..MaxBrowseFlds] of integer;
  43.     ftype:array [1..MaxBrowseFlds] of string[1];
  44.   end;
  45.   TagInfo=Class(TObject)
  46.     tagcnt:integer;
  47.     Tags,Keys:array [1..MaxTags] of string[80];
  48.   end;
  49.   oDB=class(TObject)
  50.     public
  51.       AliasName:String[11];
  52.       Area:integer;
  53.       CurOrder:integer;
  54.             constructor create(OpenDBF:string;Exclusive:boolean);
  55.       procedure Free;
  56.             { Get field info, pass in field name -  Return Value of 'fldname' }
  57.             function  s(fnm:string): string;    { full string, no trim() }
  58.             function  st(fnm:string):string;    { trim()'ed value }
  59.             function  sn(fnm:string;TruncTo:integer):string; { truncate to size }
  60.             procedure longs(fnm:string;tp:Pchar);{ fields>255 in length }
  61.             function  l(fnm:string): longint;   { field info as Longint }
  62.             function  i(fnm:string): integer;   { field info as Integer }
  63.             function  b(fnm:string): boolean;   { field info as Boolean }
  64.             function  n(fnm:string): double;    { Numeric field info as Double }
  65.             function  f(fnm:string): double;    { Numeric field info as Double }
  66.             procedure m(fnm:string;toPchar:Pchar);     { field info as Memo }
  67.             function  d(fnm:string): Longint;   { as longint: 19950115 style }
  68.             function  ds(fnm:string): string;   { as string: 10-15-95 style }
  69.             function  dj(fnm:string):longint;   { as Julian date }
  70.             {  Replace field with "newval", pass in field name
  71.                  and var of appropriate data type as needed - Replace 'fnm' with }
  72.             procedure ss(fnm:string;newval:string);    { String }
  73.             procedure longss(fnm:string;tp:Pchar);{ Char fields>255 in length }
  74.             procedure ll(fnm:string;newval:longint);   { Longint }
  75.             procedure ii(fnm:string;newval:integer);   { Integer }
  76.             procedure bb(fnm:string;newval:boolean);   { Boolean }
  77.             procedure ff(fnm:string;newval:double);    { Double }
  78.             procedure nn(fnm:string;newval:double);    { Double }
  79.             procedure mm(fnm:string;newval:pchar);     { Memo (Pchar) }
  80.             procedure dd(fnm:string;newval:longint);   { Longint NewVal: 19950115 }
  81.             { Database commands }
  82.             function  Alias:string;
  83.             procedure Append;
  84.             function  Bof:Boolean;
  85.             procedure CreateIndex(TagName,TagKey:string);
  86.             procedure Delete;  { mark record as deleted }
  87.             function  Deleted: boolean; { status of deletion flag for record }
  88.             function  Eof: boolean;
  89.             procedure GetDBFstruct(SaveTo:DBFstruct);
  90.             function  GetFullRecord:string; {return raw data, first 255 bytes only }
  91.             procedure Go(RecNo:longint);  { GoTo is reserved word, not used }
  92.             procedure GoBottom;
  93.             procedure GoTop;
  94.             function  Lastrec:longint;
  95.             function  Lock: boolean;   { try lock until succeeds }
  96.             function  aLock: boolean;  { try a few times, then return if fails }
  97.             function  LockList(var locklist:array of longint):integer;
  98.             procedure Pack;
  99.             function  RecCount: longint;
  100.             function  RecNo: longint;
  101.             procedure Recall;           { unmark record as deleted }
  102.             procedure ReIndex;
  103.             function  Seek(apattern:string): boolean;
  104.             procedure SetOrder(ToIndex:integer);  { by tag number }
  105.             procedure SetRelation(IntoAreaNum:integer;OnExpr:string);
  106.             procedure Skip;
  107.             procedure Skip2(ByCnt:integer);
  108.             procedure TagOrder(OrderByTag:String);  { by tag name }
  109.             procedure unLock;
  110.             procedure Zap;
  111.   end;
  112.  
  113. {  Public Variables and Functions }
  114.  
  115. var     DBFname:array [1..MaxDBFs] of string[50];
  116.  
  117. procedure StartDBserver;
  118. procedure StopDBserver; { Release resources }
  119. procedure Beep;
  120. function  cdow(aDow:integer):string; { day of week, Monday, etc }
  121. function  cMonth(aMonth:integer):string; { month, January, etc }
  122. function  CoreFile(FullPath:string):string;
  123. procedure CreateDBF(DBFname:string;FldCnt:integer;
  124.   var FieldName,FldType:array of String; var FldWidth,FldDecs:array of integer);
  125. function  ctod(DateStr:String):Longint;  { ctod('01/15/95') -> 19950115 }
  126. function  DateDiff(Date1Minus,Date2:longint):longint;
  127. function  datehyph(adate:longint):string; { date to string type of ' 1-15-95' }
  128. function  DateMath(DateLong:Longint;PlusMinus:Longint):Longint;
  129. function  dbUse(var pDBF:odb;aDBF:string):boolean;
  130. function  dbUseExclusive(var pDBF:odb;aDBF:string):boolean;
  131. function  dbAlias:string;
  132. procedure dbClose(var aDB:oDB);
  133. function  dbIndexOrd:integer;
  134. function  dbIsOpen(aDB:oDB):boolean;
  135. function  dbIsClosed(aDB:oDB):boolean;
  136. function  dbSelect(AnAlias:string):integer;
  137. function  dbSelectArea(ByAreaNum:integer):string;
  138. procedure DoEvents2;
  139. procedure DoEvents;
  140. function  dow(DateAslong:Longint):integer;  { day of week, Sun=1 }
  141. function  dshyph(ddd:longint):string;     { Special Date string conversion }
  142. function  dtoc(DateLong:LongInt):String; { dtoc(19940115) -> '01/15/94' }
  143. function  dtos(DateLong:Longint):String; { dtos(19940115) -> '19940115' }
  144. function  Empty(aStr:String):Boolean;  { date strings and regular strings }
  145. function  EvalExpr(StrExpr:String):String;
  146. function  GetEnv(envname:string):string;  { Get Environment String Value }
  147. function  GetUniqueAlias(StartWith:string):string;
  148. procedure GetWinSection(SectionName:string;var slist:array of string);
  149. function  GetWinSetting(SectionName,KeyName:string):string;
  150. procedure LoadTags(aDBF:oDB;var TagDat:TagInfo);
  151. function  Lower(aStr:String):String;
  152. function  lTransform(aLongInt:Longint;WithPict:String):String;
  153. function  lTrim(aStr:String):String;   { trim off leading spaces }
  154. function  Month(aDate:longint):integer; { month, 1-12 }
  155. procedure OKbox(sText:String);
  156. function  PadC(aStr:String;InWidth:Integer):String; { pad center in width }
  157. function  PadL(aStr:String;InWidth:Integer):String; { right justify in width }
  158. function  PadR(aStr:String;InWidth:Integer):String; { left justify in width }
  159. function  pp(var anInt:integer):integer;  { ii:=ii+1  ==>  pp(ii) }
  160. function  pp2(var anInt,adjby:integer):integer; { ii+=14    ==>  pp2(ii,14) }
  161. function  ProcDbl(nval:string):double; { accepts any string }
  162. function  ProcInt(nval:string):integer; { accepts any string }
  163. function  ProcLong(nval:string):longint; { accepts any string }
  164. procedure PutWinSetting(SectionName,KeyName,NewValue:string);
  165. function  Replicate(aStr:String;ForCnt:integer):String; { truncates to 255 }
  166. function  RocketVersion:string;
  167. function  Space(EmptySize:Integer):String;  { return string of spaces }
  168. function  stod(LongStr:String):Longint;  { stod('19940115') -> 19940115 }
  169. function  Str(aDbl:double;width,decs:integer):string;
  170. function  Str2(aDbl:double;width:integer):string;
  171. function  StrI(aInt:longint;width:integer):string;
  172. function  StrD(aDbl:double;ToPlaces:integer):string;
  173. function  Stuff(aStr:string;At,ForLen:integer;WithStr:string):string;
  174. function  SubStr(aStr:String;Start:Integer;Count:Integer):String;
  175. function  Transform(aDouble:Double;WithPict:String):String;
  176. function  Trim(aStr:String):String;    { trim off trailing spaces }
  177. procedure TrimStr(aPchar:Pchar);
  178. function  Upper(aStr:String):String;
  179. function  ValidDate(DateAsLong:Longint):Boolean;  { date valid? }
  180. function  xDate:longint;  { date() replacement compatible with above }
  181. function  Year(aDate:longint):integer;  { year of date, 1995 }
  182. function  YesNoBox(text:string):boolean;
  183. function  YesNoCancelBox(text:string):integer; { yes-6, no-2, cancel-7 }
  184. function  YN(aBool:Boolean):String; {Convert Boolean to string, 'Y','N' }
  185.  
  186. Implementation
  187.  
  188. uses WYNform;
  189.  
  190. var StrNull1,StrNull2:Pchar;  { used by several commands }
  191.     DoEventsCnt:integer;
  192.  
  193. function  GetDOSEnvironment:Pchar;far;external 'KERNEL';
  194.  
  195. { the following were translated from /rocket/sixcpp/stdafx.h }
  196. procedure sx_AppendBlank; far; external 'ROCKET';
  197. function  sx_Alias(AreaNo:Integer):Pchar; far; external 'ROCKET';
  198. function  sx_Bof:Integer; far; external 'ROCKET';
  199. procedure sx_Close; far; external 'ROCKET';
  200. procedure sx_CloseAll; far; external 'ROCKET';
  201. procedure sx_Commit; far; external 'ROCKET';
  202. function  sx_CreateNew(DBFname,alias:pchar;IndexType,NumOfFields:integer):integer;
  203.     far; external 'ROCKET';
  204. procedure sx_CreateField(fnm,FldType:pchar;Fwidth,Fdecs:integer);
  205.     far; external 'ROCKET';
  206. function  sx_CreateExec:boolean; far; external 'ROCKET';
  207. procedure sx_DBRlockList(ptr:pointer); far; external 'ROCKET';
  208. procedure sx_Delete; far; external 'ROCKET';
  209. function  sx_Deleted:Integer; far; external 'ROCKET';
  210. function  sx_Eof:Integer; far; external 'ROCKET';
  211. function  sx_EvalString(Expr:Pchar):Pchar; far; external 'ROCKET';
  212. function  sx_FieldCount:Integer; far; external 'ROCKET';
  213. function  sx_FieldName(fnum:Integer):Pchar; far; external 'ROCKET';
  214. function  sx_FieldNum(fnm:Pchar):Integer; far; external 'ROCKET';
  215. function  sx_FieldDecimals(fnm:Pchar):Integer; far; external 'ROCKET';
  216. function  sx_FieldType(fnm:Pchar):Pchar; far; external 'ROCKET';
  217. function  sx_FieldWidth(fnm:Pchar):Integer; far; external 'ROCKET';
  218. function  sx_Found:Integer; far; external 'ROCKET';
  219. function  sx_GetDateJulian(fnm:Pchar):Longint; far; external 'ROCKET';
  220. function  sx_GetDateString(fnm:Pchar):Pchar; far; external 'ROCKET';
  221. function  sx_GetDouble(fnm:Pchar):Double; far; external 'ROCKET';
  222. function  sx_GetInteger(fnm:Pchar):Integer; far; external 'ROCKET';
  223. function  sx_GetLogical(fnm:Pchar):Integer; far; external 'ROCKET';
  224. function  sx_GetLong(fnm:Pchar):Longint; far; external 'ROCKET';
  225. function  sx_GetMemo(fnm:Pchar;LineWidth:Integer):Pchar;
  226.     far; external 'ROCKET';
  227. procedure sx_GetRecord(IntoBuffer:Pchar); far; external 'ROCKET';
  228. function  sx_GetString(fnm:Pchar):Pchar; far; external 'ROCKET';
  229. function  sx_GetTrimString(fnm:Pchar):Pchar; far; external 'ROCKET';
  230. procedure sx_Go(ToRec:LongInt); far; external 'ROCKET';
  231. procedure sx_GoBottom; far; external 'ROCKET';
  232. procedure sx_GoTop; far; external 'ROCKET';
  233. function  sx_IndexOrd:Integer; far; external 'ROCKET';
  234. function  sx_IndexKey:Pchar; far; external 'ROCKET';
  235. function  sx_IndexTag(DBFname,TagName,TagKey:pchar;
  236.     bUnique,bDescending:boolean;CondExpr:pchar):integer;
  237.     far; external 'ROCKET';
  238. function  sx_Locked(RecNo:LongInt):Integer; far; external 'ROCKET';
  239. function  sx_LockCount:integer; far; external 'ROCKET';
  240. procedure sx_MemDealloc(aPointer:Pchar); far; external 'ROCKET';
  241. procedure sx_Pack; far; external 'ROCKET';
  242. procedure sx_Recall; far; external 'ROCKET';
  243. function  sx_RecCount:Longint; far; external 'ROCKET';
  244. function  sx_RecNo:Longint; far; external 'ROCKET';
  245. function  sx_RecSize:Longint; far; external 'ROCKET';
  246. procedure sx_ReIndex; far; external 'ROCKET';
  247. procedure sx_Replace(fnm:Pchar;FldType:Integer;PtrData:Pchar);
  248.     far; external 'ROCKET';
  249. function  sx_Rlock(RecNo:Longint):Integer; far; external 'ROCKET';
  250. function  sx_Seek(aPattern:Pchar):Integer; far; external 'ROCKET';
  251. function  sx_Select(AreaNo:Integer):Integer; far; external 'ROCKET';
  252. procedure sx_SetDeleted(OnOff:Integer); far; external 'ROCKET';
  253. procedure sx_SetExact(OnOff:Integer); far; external 'ROCKET';
  254. function  sx_SetHandles(ToCnt:Integer):Integer; far; external 'ROCKET';
  255. function  sx_SetOrder(ToIndexNo:Integer):Integer; far; external 'ROCKET';
  256. procedure sx_SetRelation(IntoArea:integer;UseExpr:Pchar); far;
  257.                         external 'ROCKET';
  258. procedure sx_SetStringType(cstyle:Integer); far; external 'ROCKET';
  259. procedure sx_Skip(MoveCnt:Longint); far; external 'ROCKET';
  260. function  sx_TagArea(TagName:Pchar):Integer; far; external 'ROCKET';
  261. function  sx_TagName(TagIndex:Integer):Pchar; far; external 'ROCKET';
  262. procedure sx_Unlock(RecNo:Longint); far; external 'ROCKET';
  263. function  sx_Use(Fname:pchar;dAlias:pchar;OpenMode:Integer;
  264.     RDDtype:Integer): Integer;
  265.     far; external 'ROCKET';
  266. function  sx_Version:pchar; far; external 'ROCKET';
  267. function  sx_WorkArea(AliasName:Pchar):Integer; far; external 'ROCKET';
  268. procedure sx_Zap; far; external 'ROCKET';
  269.  
  270. function RocketVersion:string;
  271. begin
  272.   result:=strpas(sx_Version);
  273. end;
  274.  
  275. function  YesNoBox(text:string):boolean;
  276. var ret:integer;
  277.     tyn:TYNform;
  278. begin
  279.   tyn:=TYNform.create(application);
  280.   tyn.setup(2,'Job Cost',text);
  281.   ret:=tyn.showmodal;
  282.     Result:=(ret=mrYES);
  283. end;
  284.  
  285. function  YesNoCancelBox(text:string):integer; { yes-6, no-2, cancel-7 }
  286. var tyn:TYNform;
  287. begin
  288.   tyn:=TYNform.create(application);
  289.   tyn.setup(3,'Job Cost',text);
  290.   Result:=tyn.showmodal;
  291. end;
  292.  
  293. procedure OKbox(sText:String);
  294. var tyn:TYNform;
  295. begin
  296.   tyn:=TYNform.create(application);
  297.   tyn.setup(1,'Job Cost',stext);
  298.   tyn.showmodal;
  299. end;
  300.  
  301. procedure GetWinSection(SectionName:string;var slist:array of string);
  302. var tp,p1,p2,p3,p4:pchar;
  303.         ii:integer;
  304. begin
  305.     p1:=stralloc(120);
  306.     p2:=nil;
  307.     p3:=stralloc(120);
  308.     p4:=stralloc(800);
  309.     strpcopy(p1,SectionName);
  310.     strpcopy(p3,'');
  311.     strpcopy(p4,'');
  312.     GetProfileString(p1,p2,p3,p4,798);
  313.     tp:=p4;  { must use second var because we're changing a pointer }
  314.     for ii:=0 to high(slist) do slist[ii]:='';
  315.     ii:=-1;
  316.     { note only the text before the '=' is returned, not the whole line
  317.         you have to make a second call with GetWinSetting() to get the
  318.         rest of the line }
  319.     while (tp^<>#0) and (ii<high(slist)) do begin
  320.         pp(ii);
  321.         slist[ii]:=strpas(tp);
  322.         inc(tp,length(slist[ii])+1);
  323.     end;
  324.     strdispose(p1);
  325.     strdispose(p3);
  326.     strdispose(p4);
  327. end;
  328.  
  329.  
  330. function GetWinSetting(SectionName,KeyName:string):string;
  331. var p1,p2,p3,p4:pchar;
  332. begin
  333.     p1:=stralloc(120);
  334.     p2:=stralloc(120);
  335.     p3:=stralloc(120);
  336.     p4:=stralloc(120);
  337.     strpcopy(p1,SectionName);
  338.     strpcopy(p2,KeyName);
  339.     strpcopy(p3,'');
  340.     strpcopy(p4,'');
  341.     GetProfileString(p1,p2,p3,p4,120);
  342.     Result:=strpas(p4);
  343.     strdispose(p1);
  344.     strdispose(p2);
  345.     strdispose(p3);
  346.     strdispose(p4);
  347. end;
  348.  
  349. procedure PutWinSetting(SectionName,KeyName,NewValue:string);
  350. var p1,p2,p3,p4:pchar;
  351. begin
  352.     p1:=stralloc(120);
  353.     p2:=stralloc(120);
  354.     p3:=stralloc(120);
  355.     strpcopy(p1,SectionName);
  356.     strpcopy(p2,KeyName);
  357.     strpcopy(p3,NewValue);
  358.     WriteProfileString(p1,p2,p3);
  359.     strdispose(p1);
  360.     strdispose(p2);
  361.     strdispose(p3);
  362. end;
  363.  
  364. function getenv(envname:string):string;
  365. var buf1:pchar;
  366.         tb:array [0..2000] of char;
  367.         ii,tcnt,jj,kk:integer;
  368.         tt,utt:string;
  369.         tlist:array [1..30] of string[130];
  370. begin
  371.     buf1:=tb;
  372.     buf1:=GetDOSEnvironment;
  373.     tcnt:=0;
  374.     tt:=strpas(buf1);
  375.     utt:=uppercase(tt);
  376.     Result:='';
  377.     envname:=uppercase(envname);
  378.     jj:=pos('=',utt);
  379.     if pos(envname,utt)>0 then begin
  380.         Result:=copy(tt,jj+1,128);
  381.         exit;
  382.     end;
  383.     while (length(tt)>0) and (tcnt<30) do begin
  384.         pp(tcnt);
  385.         tlist[tcnt]:=tt;
  386.         buf1:=buf1+length(tt)+1;
  387.         tt:=strpas(buf1);
  388.         utt:=uppercase(tt);
  389.         envname:=uppercase(envname);
  390.         jj:=pos('=',utt);
  391.         if pos(envname,utt)>0 then begin
  392.             Result:=copy(tt,jj+1,128);
  393.             break;
  394.         end;
  395.     end;
  396. end;
  397.  
  398. function Space(EmptySize:Integer):String;  { return string of spaces }
  399. var tt,tt2:string;
  400.         ii:integer;
  401. begin
  402.     tt:='                              ';
  403.     tt2:='';
  404.     for ii:=1 to 5 do tt2:=tt2+tt;
  405.     ii:=length(tt2);
  406.     Result:=copy(tt2,1,EmptySize);
  407. end;
  408.  
  409. function datehyph(adate:longint):string;
  410. var ii:integer;
  411.         ds,tt,tt2:string[10];
  412. begin
  413.     ds:=dtoc(adate);
  414.     if not empty(ds) then begin
  415.         tt2:='';
  416.         for ii:=1 to 8 do begin
  417.             tt:=substr(ds,ii,1);
  418.             if (ii=1) and (tt='0') then tt:=' ';
  419.             if tt='/' then tt:='-';
  420.             tt2:=tt2+tt;
  421.         end;
  422.         result:=tt2;
  423.     end else Result:=space(8);
  424. end;
  425.  
  426. function NoDashDate(adate:string):string;
  427. var ii,jj:integer;
  428.         tt,tt2:string[10];
  429. begin
  430.   result:=adate;
  431.     if pos('-',adate)>0 then begin
  432.         tt2:='';
  433.     jj:=length(adate);
  434.         for ii:=1 to jj do begin
  435.             tt:=substr(adate,ii,1);
  436.             if tt='-' then tt:='/';
  437.             tt2:=tt2+tt;
  438.         end;
  439.         result:=tt2;
  440.     end;
  441. end;
  442.  
  443. function pp(var anInt:integer):integer;  { ii:=ii+1  ==>  pp(ii) }
  444. begin
  445.   result:=anInt;  { usage:  lp.p(line++,5,'Hi') -> lp.p(pp(line),5,'Hi') } 
  446.     anInt:=anInt+1;
  447. end;
  448.  
  449. function pp2(var anInt,adjby:integer):integer; { ii+=14    ==>  pp2(ii,14) }
  450. begin
  451.   result:=anInt;
  452.     anInt:=anInt+adjby;
  453. end;
  454.  
  455. function  ProcInt(nval:string):integer;
  456. var tdbl:double;
  457. begin
  458.   tdbl:=ProcDbl(nval);
  459.   result:=StrToInt(ltrim(transform(tdbl,'99999999')));
  460. end;
  461.  
  462. function  ProcLong(nval:string):longint;
  463. var tdbl:double;
  464. begin
  465.   tdbl:=ProcDbl(nval);
  466.   result:=StrToInt(ltrim(transform(tdbl,'99999999')));
  467. end;
  468.  
  469. function procdbl(nval:string):double;
  470. var decs,prnum,jj:double;
  471.         ii:integer;
  472.         ist:string[30];
  473.         pastdec,isminus:boolean;
  474. begin
  475.     prnum:=0.00;
  476.     pastdec:=False;
  477.     isminus:=False;
  478.     decs:=1.0;
  479.     if not empty(nval) then begin
  480.         for ii:=1 to length(nval) do begin
  481.             ist:=Copy(nval,ii,1);
  482.             if ist='-' then begin
  483.                 isminus:=True;
  484.             End;
  485.             if ist='.' then begin
  486.                 pastdec:=True;
  487.             End Else
  488.             Begin
  489.                 if (ist >= '0') And (ist <= '9') then begin
  490.                     jj:=StrToFloat(ist);
  491.                     prnum := prnum * 10.0;
  492.                     prnum := prnum + jj;
  493.                     if pastdec then begin
  494.                         decs:=decs / 10.0;
  495.                     End;
  496.                 End;
  497.             End;
  498.         End;
  499.         if isminus then begin
  500.             prnum:=prnum * decs * -1;
  501.         End Else
  502.         Begin
  503.             prnum:=prnum * decs;
  504.         End;
  505.         if Not pastdec then begin
  506.             prnum:=int(prnum);
  507.         End;
  508.     end;
  509.     Result:=prnum;
  510. end;
  511.  
  512.  
  513. function dshyph(ddd:longint):string;
  514. var tt,tt2:string[20];
  515. begin
  516.     if ddd=ctod('01/01/99') then
  517.         Result:='   W/A  '
  518.     else begin
  519.         if ddd=ctod('12/01/99') then
  520.             Result:=' 4-STOCK'
  521.         else begin
  522.             tt:=dtos(ddd);
  523.             tt2:=substr(tt,5,2);
  524.             tt:=substr(tt,3,2);
  525.             if tt='99' then
  526.                 Result:=padl(inttostr(strtoint(tt2))+'-WARM',8)
  527.             else begin
  528.                 if ddd>ctod('01/01/99') then
  529.                     Result:='BAD DATE'
  530.                 else
  531.                     Result:=datehyph(ddd);
  532.             end;
  533.         end;
  534.     end;
  535. end;
  536.  
  537. function PadC(aStr:String;InWidth:Integer):String; { pad center in width }
  538. var ii,ll:integer;
  539. begin
  540.     ll:=length(aStr);
  541.     if ll>=InWidth then Result:=copy(aStr,1,Inwidth)  { truncate }
  542.     else begin
  543.         ii:=(InWidth-ll) div 2;
  544.         if ii>0 then Result:=space(ii)+aStr;
  545.         ll:=length(Result);
  546.         if ll<InWidth then Result:=Result+space(InWidth-ll)
  547.     end;
  548. end;
  549.  
  550. function PadL(aStr:String;InWidth:Integer):String; { right justify in width }
  551. var ll:integer;
  552. begin
  553.     ll:=length(aStr);
  554.     if ll>=InWidth then Result:=copy(aStr,1,Inwidth)  { truncate }
  555.     else Result:=space(InWidth-ll)+aStr;
  556. end;
  557.  
  558. function PadR(aStr:String;InWidth:Integer):String; { left justify in width }
  559. var ll:integer;
  560. begin
  561.     ll:=length(aStr);
  562.     if ll>=InWidth then Result:=copy(aStr,1,Inwidth)  { truncate }
  563.     else Result:=aStr+space(InWidth-ll);
  564. end;
  565.  
  566. function YN(aBool:Boolean):String;
  567. begin
  568.     Result:='N';
  569.     if aBool then Result:='Y';
  570. end;
  571.  
  572. function dow(DateAslong:Longint):integer;  { day of week, Sun=1 }
  573. var tdate:TDateTime;
  574.         tt,tt2:string[20];
  575. begin
  576.     if DateAsLong>0 then begin
  577.         tt:=IntToStr(DateAsLong);
  578.         tt2:=copy(tt,5,2)+'/'+copy(tt,7,2)+'/'+copy(tt,1,4);
  579.         tdate:=StrToDate(tt2);
  580.         Result:=DayOfWeek(tdate);
  581.     end else Result:=0;
  582. end;
  583.  
  584. function cdow(aDow:integer):string;
  585. begin
  586.     Result:='Unknown';
  587.     case aDOW of
  588.         1:Result:='Sunday';
  589.         2:Result:='Monday';
  590.         3:Result:='Tuesday';
  591.         4:Result:='Wednesday';
  592.         5:Result:='Thursday';
  593.         6:Result:='Friday';
  594.         7:Result:='Saturday';
  595.     end;
  596. end;
  597.  
  598. function month(aDate:longint):integer;
  599. var tt:string;
  600. begin
  601.     Result:=0;
  602.     if aDate>0 then begin
  603.         Result:=strtoint(copy(inttostr(aDate),5,2));
  604.     end;
  605. end;
  606.  
  607. function cmonth(aMonth:integer):string;
  608. begin
  609.     Result:='Unknown';
  610.     case aMonth of
  611.         1:Result:='January';
  612.         2:Result:='February';
  613.         3:Result:='March';
  614.         4:Result:='April';
  615.         5:Result:='May';
  616.         6:Result:='June';
  617.         7:Result:='July';
  618.         8:Result:='August';
  619.         9:Result:='September';
  620.      10:Result:='October';
  621.      11:Result:='November';
  622.      12:Result:='December';
  623.     end;
  624. end;
  625.  
  626. function year(aDate:longint):integer;
  627. var tt:string;
  628. begin
  629.     Result:=0;
  630.     if aDate>0 then begin
  631.         Result:=strtoint(copy(inttostr(aDate),1,4));
  632.     end;
  633. end;
  634.  
  635. function StrI(aInt:longint;width:integer):string;
  636. begin
  637.   Result:=ltransform(aInt,copy('99999999',1,width))
  638. end;
  639.  
  640. function ValidDate(DateAslong:Longint):Boolean;  { date valid? }
  641. var tdate:TDateTime;
  642.         tt,tt2:string[20];
  643. begin
  644.   Result:=true;
  645.   if DateAsLong>0 then begin  { Zero (empty date) is always valid }
  646.     try
  647.       tt:=padr(IntToStr(DateAsLong),8);
  648.       tt2:=copy(tt,5,2)+'/'+copy(tt,7,2)+'/'+copy(tt,1,4);
  649.       tdate:=StrToDate(tt2);
  650.       Result:=True;  { if we made it here, it was OK }
  651.     except
  652.       { Must turn-off option on Environment Options window
  653.         "Break on Exception" in "Debugging" section while testing }
  654.       Result:=False;
  655.     end;
  656.   end;
  657. end;
  658.  
  659. procedure TrimStr(aPchar:Pchar);
  660. var tp:Pchar;
  661.     ii:integer;
  662. begin
  663.   if strlen(apchar)>0 then begin
  664.     tp:=apchar;
  665.       inc(tp,strlen(apchar)-1);
  666.     while true do begin
  667.       if tp^<>#32 then begin
  668.         inc(tp,1);
  669.         tp^:=#0;
  670.         break;
  671.       end;
  672.       if tp=apchar then break;
  673.       inc(tp,-1);
  674.     end;
  675.     ii:=strlen(apchar);
  676.     if tp=apchar then apchar^:=#0;
  677.   end;
  678. end;
  679.  
  680. function Trim(aStr:String):String;   { trim off trailing spaces }
  681. var ii,kk,ll:integer;
  682. begin
  683.     ll:=length(aStr);
  684.     Result:=aStr;
  685.     if ll>0 then begin
  686.         kk:=0;
  687.         for ii:=ll downto 1 do begin
  688.             if aStr[ii]<>#32 then begin
  689.                 kk:=ii;
  690.                 break;
  691.             end;
  692.         end;
  693.         if kk>0 then Result:=copy(astr,1,kk)
  694.         else Result:='';
  695.     end;
  696. end;
  697.  
  698. function stuff(aStr:string;At,ForLen:integer;WithStr:string):string;
  699. var front,back:string;
  700. begin
  701.   front:='';
  702.   back:='';
  703.   if At>1 then front:=copy(aStr,1,at-1);
  704.   if At<length(aStr) then back:=copy(aStr,at+ForLen,255);
  705.   Result:=front+WithStr+back;
  706. end;
  707.  
  708. function SubStr(aStr:String;Start:Integer;Count:Integer):String;   { same as copy() }
  709. begin
  710.     { substr() same args as Delphi copy() }
  711.     Result:=Copy(aStr,Start,Count);
  712. end;
  713.  
  714. function  Replicate(aStr:String;ForCnt:integer):String;
  715. var ii,jj:integer;
  716.         tt:string;
  717. begin
  718.     jj:=length(astr)*ForCnt;
  719.     if jj>255 then begin
  720.         ii:=255 div jj;
  721.     end;
  722.     tt:='';
  723.     for ii:=1 to jj do tt:=tt+aStr;
  724.     Result:=tt;
  725. end;
  726.  
  727. function Upper(aStr:String):String;   { same as uppercase }
  728. begin
  729.     Result:=UpperCase(aStr);
  730. end;
  731.  
  732. function  Lower(aStr:String):String;
  733. begin
  734.   Result:=LowerCase(aStr);
  735. end;
  736.  
  737. function lTrim(aStr:String):String;   { trim off trailing spaces }
  738. var ii,kk,ll:integer;
  739. begin
  740.     ll:=length(aStr);
  741.     Result:=aStr;
  742.     if ll>0 then begin
  743.         kk:=0;
  744.         for ii:=1 to ll do begin
  745.             if aStr[ii]<>#32 then begin
  746.                 kk:=ii;
  747.                 break;
  748.             end;
  749.         end;
  750.         if kk>0 then Result:=copy(astr,kk,254)
  751.         else Result:='';
  752.     end;
  753. end;
  754.  
  755. function Empty(aStr:String):Boolean;
  756. var ii,ll:integer;
  757.         res:boolean;
  758. begin
  759.     if length(aStr)=0 then res:=true
  760.     else
  761.     begin
  762.         ll:=length(aStr);
  763.         if (ll=8) or (ll=10) then { check for date? }
  764.         begin
  765.             if (aStr[3]=#47) and (aStr[6]=#47) then { chars 3 and 6 are "/" }
  766.             begin
  767.                 ll:=2; { only need to test first 2 chars of dates }
  768.                 if pos('00',aStr)=1 then ll:=0  { ignore '00/00/00' }
  769.             end;
  770.         end;
  771.         res:=True;
  772.         if ll>0 then begin
  773.             for ii:=1 to ll do begin
  774.                 if aStr[ii]<>#32 then begin
  775.                     res:=False;
  776.                     break;
  777.                 end;
  778.             end;
  779.         end;
  780.     end;
  781.     Result:=res;
  782. end;
  783.  
  784. { True/False tester for DLL boolean (integer) return values }
  785. function tf(AnInt:Integer):Boolean;
  786. begin
  787.     Result:=AnInt<>0; { True=Any Non-Zero Value }
  788. end;
  789.  
  790. procedure StopDBserver;
  791. begin
  792.     sx_CloseAll;
  793.     StrDispose(StrNull1);
  794.     StrDispose(StrNull2);
  795. end;
  796.  
  797. procedure delay(ForSeconds:integer);
  798. { delay for interval in seconds }
  799. var tt:TDateTime;
  800.         hr,thr,mn,sc,ms:word;
  801.         ll,cur,rng:LongInt;
  802. begin
  803.     tt:=now;
  804.     rng:=ForSeconds;
  805.     DecodeTime(tt,hr,mn,sc,ms);
  806.     thr:=hr;
  807.     cur:=(hr*3600)+(mn*60)+sc;
  808.     ll:=(hr*3600)+(mn*60)+sc;
  809.     while rng>(ll-cur) do begin
  810.         tt:=now;
  811.         DecodeTime(tt,hr,mn,sc,ms);
  812.         if hr<thr then hr:=hr+24;  { anyone work at midnight? }
  813.         ll:=(hr*3600)+(mn*60)+sc;
  814.     end;
  815. end;
  816.  
  817. function EvalExpr(StrExpr:String):String;
  818. begin
  819.     { An error will occur if no DBF's are open }
  820.     Result:=StrPas(sx_EvalString(StrPCopy(StrNull1,StrExpr)));
  821. end;
  822.  
  823. function ctod(DateStr:String):Longint;  { ctod('01/15/95') -> 19950115 }
  824. var tt:string;
  825. begin
  826.     { pass in date string of form '01/15/94' }
  827.     DateStr:=NoDashDate(DateStr); { convert 00-00-00 to 00/00/00 first }
  828.     if empty(DateStr) then Result:=0
  829.     else begin
  830.         tt:=EvalExpr('ctod("'+DateStr+'")');
  831.         if empty(tt) then Result:=0
  832.                                  else Result:=StrToInt(tt);
  833.     end;
  834. end;
  835.  
  836. function dtoc(DateLong:LongInt):String; { dtoc(19940115) -> '01/15/94' }
  837. begin
  838.     { pass in date as longint of form 19940115 }
  839.   Result:='  /  /  ';
  840.     if (DateLong>0) and ValidDate(DateLong) then
  841.         Result:=EvalExpr('dtoc(stod("'+IntToStr(DateLong)+'"))');
  842. end;
  843.  
  844. function dtos(DateLong:Longint):String; { dtos(19940115) -> '19940115' }
  845. begin
  846.     { pass in date as longint of form 19940115 }
  847.   Result:=space(8);
  848.     if (DateLong>0) and ValidDate(DateLong) then
  849.         Result:=EvalExpr('dtos(stod("'+IntToStr(DateLong)+'"))');
  850. end;
  851.  
  852. function stod(LongStr:String):Longint;  { stod('19940115') -> 19940115 }
  853. var tt:string[20];
  854. begin
  855.     { pass in date string of form '19940115' }
  856.     if empty(LongStr) then tt:='0'
  857.         else tt:=LongStr;
  858.     if not ValidDate(StrToInt(tt)) then Result:=0
  859.         else Result:=StrToInt(EvalExpr('stod("'+LongStr+'")'));
  860. end;
  861.  
  862. function DateDiff(Date1Minus,Date2:longint):longint;
  863. var tt:string;
  864.     CurAlias:integer;
  865.     ddb:oDB;
  866. begin
  867.     { pass in date string of form 19940115 }
  868.     Result:=-10000;   { arbitrary error return value }
  869.   ddb:=Nil;
  870.     dbUse(ddb,TempExprDBF);
  871.     if ddb.aLock then begin
  872.         if empty(dtoc(Date1Minus)) Or empty(dtoc(Date2)) then Result:=-10000
  873.         else begin
  874.             ddb.dd('date1',Date1Minus);
  875.             ddb.dd('date2',Date2);
  876.             Result:=ddb.dj('date1')-ddb.dj('date2');
  877.         end;
  878.     end;
  879.     ddb.Free;
  880. end;
  881.  
  882. function DateMath(DateLong:Longint;PlusMinus:Longint):Longint;
  883. var tt:string[10];
  884. begin
  885.     if PlusMinus<0 then tt:=''   { need to add sign for plus numbers }
  886.                                  else tt:='+';
  887.     { pass in date string of form '19940115' }
  888.     Result:=StrToInt(EvalExpr('dtos(stod("'+IntToStr(DateLong)+'")'+tt+
  889.         IntToStr(PlusMinus)+')'));
  890. end;
  891.  
  892. function Transform(aDouble:Double;WithPict:String):String;
  893. begin
  894.     Result:=EvalExpr('transform('+format('%13.4f',[aDouble])+
  895.         ',"'+WithPict+'")');
  896. end;
  897.  
  898. function lTransform(aLongInt:Longint;WithPict:String):String;
  899. begin
  900.     Result:=EvalExpr('transform('+IntToStr(aLongInt)+
  901.         ',"'+WithPict+'")');
  902. end;
  903.  
  904. function  Str2(aDbl:double;width:integer):string;
  905. begin
  906.   Result:=str(aDbl,Width,0);
  907. end;
  908.  
  909. function  StrD(aDbl:double;ToPlaces:integer):string;
  910. var InWidth:integer;
  911. begin
  912.   InWidth:=8;
  913.     if ToPlaces>0 then InWidth:=8+1+ToPlaces;
  914.   Result:=ltrim(str(aDbl,InWidth,ToPlaces));
  915. end;
  916.  
  917. function str(aDbl:double;width,decs:integer):string;
  918. var nines,before,after:string[30];
  919.     ii:integer;
  920. begin
  921.   nines:='99999999999999';
  922.   if decs>0 then begin
  923.       ii:=width-(decs+1);
  924.         before:=copy(nines,1,ii);
  925.         after:='.'+copy(nines,1,decs);
  926.     end else begin
  927.         before:=copy(nines,1,width);
  928.         after:='';
  929.     end;
  930.     Result:=transform(aDbl,before+after);
  931. end;
  932.  
  933. function xDate:longint;
  934. begin
  935.     Result:=StrToInt(EvalExpr('date()'));
  936. end;
  937.  
  938. function dbIndexOrd:integer;
  939. begin
  940.   Result:=sx_IndexOrd;
  941. end;
  942.  
  943. procedure LoadTags(aDBF:oDB;var TagDat:TagInfo);
  944. var ii,CurIndex:integer;
  945. begin
  946.     sx_Select(aDBF.Area);
  947.   with TagDat do begin
  948.     tagcnt:=0;
  949.     CurIndex:=sx_IndexOrd;
  950.     for ii:=1 to MaxTags do begin
  951.       tags[ii]:=StrPas(sx_TagName(ii));
  952.       if length(tags[ii])>0 then begin
  953.                 pp(tagcnt);
  954.         sx_SetOrder(ii);
  955.         keys[ii]:=StrPas(sx_IndexKey);
  956.       end else break;
  957.     end;
  958.   end;
  959.     sx_SetOrder(CurIndex);
  960. end;
  961.  
  962. function CoreFile(FullPath:string):string;
  963. var ii:integer;
  964. { Get core file name for aliases, no path, no extension }
  965. begin
  966.     ii:=pos('\',FullPath);
  967.     while ii>0 do begin
  968.         FullPath:=Copy(FullPath,ii+1,100);
  969.         ii:=pos('\',FullPath);
  970.     end;
  971.     ii:=pos('.',FullPath);
  972.     if ii>1 then FullPath:=Copy(FullPath,1,ii-1);
  973.     Result:=upper(FullPath);
  974. end;
  975.  
  976. function GetUniqueAlias(StartWith:string):string;
  977. var ii,kk,ll:integer;
  978. begin
  979.     kk:=sx_WorkArea(strpcopy(strnull1,StartWith));
  980.     ll:=length(StartWith);
  981.     if ll>8 then ll:=8;
  982.     { check to see if it already exists, if so try something else }
  983.     ii:=2;
  984.     while kk>0 do begin
  985.         StartWith:=upper(copy(StartWith,1,ll))+inttostr(ii);
  986.         pp(ii);
  987.         kk:=sx_WorkArea(strpcopy(strnull1,StartWith));
  988.     end;
  989.     Result:=StartWith;
  990. end;
  991.  
  992. procedure CreateDBF(DBFname:string;FldCnt:integer;
  993.     var FieldName,FldType:array of String;
  994.     var FldWidth,FldDecs:array of integer);
  995. var aliasname:string;
  996.         ii:integer;
  997. begin
  998.     aliasname:=CoreFile(dbfname);
  999.     if FileExists(dbfname+'.dbf') then begin
  1000.         if YesNoBox('CREATE DBF - File Exists: '+
  1001.             upper(dbfname+'.dbf')+', Delete First') then begin
  1002.                 DeleteFile(dbfname+'.dbf');
  1003.                 if FileExists(dbfname+'.cdx') then DeleteFile(dbfname+'.cdx')
  1004.             end else Exit;
  1005.     end;
  1006.     sx_CreateNew(StrPCopy(StrNull1,DBFname+'.dbf'),
  1007.         StrPCopy(StrNull2,aliasname),sx_DBFCDX,high(FieldName)+1);
  1008.     for ii:=0 to FldCnt-1 do begin
  1009.         if not empty(FieldName[ii]) then
  1010.             sx_CreateField(StrPCopy(StrNull1,upper(FieldName[ii])),
  1011.                 StrPCopy(StrNull2,upper(FldType[ii])),FldWidth[ii],FldDecs[ii]);
  1012.     end;
  1013.     sx_CreateExec;
  1014.     sx_Close;
  1015. end;
  1016.  
  1017. procedure oDB.CreateIndex(TagName,TagKey:string);
  1018. { assumes DBF opened with UseExclusive }
  1019. begin
  1020.     sx_Select(Area);
  1021.     sx_IndexTag(Nil,StrPCopy(StrNull1,upper(TagName)),
  1022.         StrPCopy(StrNull2,upper(TagKey)),False,False,Nil);
  1023. end;
  1024.  
  1025. procedure oDB.GetDBFstruct(SaveTo:DBFstruct);
  1026. var ii:integer;
  1027. begin
  1028.     sx_Select(Area);
  1029.     with SaveTo do begin
  1030.         fcount:=sx_FieldCount;
  1031.         if fcount>MaxBrowseFlds then fcount:=MaxBrowseFlds;  { sxBrowse limit }
  1032.         if fcount>0 then begin
  1033.             for ii:=1 to fcount do begin
  1034.                 fname[ii]:=StrPas(sx_FieldName(ii));
  1035.                 ftype[ii]:=StrPas(sx_FieldType(StrPCopy(StrNull1,fname[ii])));
  1036.                 fwidth[ii]:=sx_FieldWidth(StrPCopy(StrNull1,fname[ii]));
  1037.                 fdecs[ii]:=sx_FieldDecimals(StrPCopy(StrNull1,fname[ii]));
  1038.             end;
  1039.         end;
  1040.     end;
  1041. end;
  1042.  
  1043. procedure Beep;
  1044. begin
  1045.     MessageBeep(MB_OK);
  1046. end;
  1047.  
  1048. procedure DoEvents;
  1049. begin
  1050.     Application.ProcessMessages;
  1051. end;
  1052.  
  1053. procedure DoEvents2;
  1054. begin
  1055.     pp(DoEventsCnt);
  1056.     if DoEventsCnt=8 then begin
  1057.         Application.ProcessMessages;
  1058.         DoEventsCnt:=0;
  1059.     end;
  1060. end;
  1061.  
  1062. function dbAlias:string;
  1063. begin
  1064.     if sx_WorkArea(Nil)>0 then
  1065.         Result:=StrPas(sx_Alias(0))
  1066.     else Result:='';
  1067. end;
  1068.  
  1069. procedure dbClose(var aDB:oDB);
  1070. begin
  1071.   if aDB<>Nil then begin
  1072.       aDB.Free;
  1073.       aDB:=Nil;
  1074.   end;
  1075. end;
  1076.  
  1077. function dbIsClosed(aDB:oDB):boolean;
  1078. begin
  1079.   Result:=(aDB=Nil);
  1080. end;
  1081.  
  1082. function dbIsOpen(aDB:oDB):boolean;
  1083. begin
  1084.   Result:=(aDB<>Nil);
  1085. end;
  1086.  
  1087. function dbUse(var pDBF:odb;aDBF:string):boolean;
  1088. begin
  1089.   result:=false;
  1090.   if pDBF<>Nil then begin
  1091.       OKBox('Error, Attempted To Open With Non-Nil Handle? '+
  1092.           upper(DBFname[pDBF.Area]));
  1093.     end else begin
  1094.     pDBF:=oDB.Create(aDBF,false);
  1095.         result:=(pDBF.area>0);  { check area number to see if opened OK }
  1096.   end;
  1097. end;
  1098.  
  1099. function dbUseExclusive(var pDBF:odb;aDBF:string):boolean;
  1100. begin
  1101.   result:=false;
  1102.   if pDBF<>Nil then begin
  1103.       OKBox('Error, Attempted To Open With Non-Nil Handle? '+
  1104.           upper(DBFname[pDBF.Area]));
  1105.     end else begin
  1106.     pDBF:=oDB.Create(aDBF,true);
  1107.         result:=(pDBF.area>0);  { check area number to see if opened OK }
  1108.   end;
  1109. end;
  1110.  
  1111. function dbSelect(AnAlias:string):integer;
  1112. begin
  1113.     Result:=sx_WorkArea(strpcopy(strnull1,AnAlias));
  1114. end;
  1115.  
  1116. function dbSelectArea(ByAreaNum:integer):string;
  1117. var tt:string[20];
  1118.         ii:integer;
  1119. begin
  1120.     Result:='';
  1121.     ii:=sx_workarea(nil); { make sure at least one area open }
  1122.     if sx_WorkArea(Nil)>0 then begin
  1123.         tt:=StrPas(sx_Alias(ByAreaNum));
  1124.         if Not Empty(tt) then begin
  1125.             Result:=tt;  { return alias name in ByAreaNum }
  1126.         end;
  1127.     end;
  1128. end;
  1129.  
  1130. constructor oDB.create(OpenDBF:string;Exclusive:boolean);
  1131. var ii:integer;
  1132. begin
  1133.   inherited create;
  1134.     Area:=0;
  1135.     AliasName:=GetUniqueAlias(CoreFile(OpenDBF));
  1136.     if not FileExists(OpenDBF+'.dbf') then
  1137.         ShowMessage('DBF not found: '+upper(OpenDBF+'.dbf'));
  1138.   if Exclusive then
  1139.         ii:=sx_Use(StrPCopy(StrNull1,OpenDBF),
  1140.             StrPCopy(StrNull2,aliasname),sx_EXCLUSIVE,sx_DBFCDX)
  1141.   else
  1142.         ii:=sx_Use(StrPCopy(StrNull1,OpenDBF),
  1143.             StrPCopy(StrNull2,aliasname),sx_READWRITE,sx_DBFCDX);
  1144.     if ii>0 then begin
  1145.         DBFname[ii]:=upper(OpenDBF);
  1146.         Area:=ii;
  1147.     SetOrder(1);
  1148.     end;
  1149. end;
  1150.  
  1151. procedure oDB.Free;
  1152. begin
  1153.     sx_Select(Area);
  1154.   sx_Close;
  1155. end;
  1156.  
  1157. function oDB.s(fnm:string): string;
  1158. begin
  1159.     sx_Select(Area);
  1160.   Result:=StrPas(sx_GetString(StrPCopy(StrNull1,fnm)))
  1161. end;
  1162.  
  1163. function oDB.st(fnm:string): string;
  1164. begin
  1165.     sx_Select(Area);
  1166.     Result:=StrPas(sx_GetTrimString(StrPCopy(StrNull1,fnm)))
  1167. end;
  1168.  
  1169. function  oDB.sn(fnm:string;TruncTo:integer):string;
  1170. var tt:string;
  1171. begin
  1172.     sx_Select(Area);
  1173.     tt:=self.s(fnm);
  1174.     if length(tt)<=TruncTo then Result:=Copy(tt,1,TruncTo)
  1175.                                                  else Result:=Padr(tt,TruncTo);
  1176. end;
  1177.  
  1178. function oDB.l(fnm:string): longint;
  1179. begin
  1180.     sx_Select(Area);
  1181.     Result:=sx_GetLong(StrPCopy(StrNull1,fnm))
  1182. end;
  1183.  
  1184. function oDB.i(fnm:string): integer;
  1185. begin
  1186.     sx_Select(Area);
  1187.     Result:=sx_GetInteger(StrPCopy(StrNull1,fnm))
  1188. end;
  1189.  
  1190. function oDB.b(fnm:string): boolean;
  1191. begin
  1192.     sx_Select(Area);
  1193.     Result:=tf(sx_GetLogical(StrPCopy(StrNull1,fnm)))
  1194. end;
  1195.  
  1196. function oDB.f(fnm:string): double;
  1197. begin
  1198.     { Minor bug: can't use sx_GetDouble yet }
  1199.     { S/B Result:=sx_GetDouble(StrPCopy(StrNull1,fnm)); }
  1200.     sx_Select(Area);
  1201.     Result:=ProcDbl(StrPas(sx_GetString(StrPCopy(StrNull1,fnm))))
  1202. end;
  1203.  
  1204. function oDB.n(fnm:string): double;
  1205. begin
  1206.     { Minor bug: can't use sx_GetDouble yet }
  1207.     { S/B Result:=sx_GetDouble(StrPCopy(StrNull1,fnm)); }
  1208.     sx_Select(Area);
  1209.     Result:=ProcDbl(StrPas(sx_GetString(StrPCopy(StrNull1,fnm))))
  1210. end;
  1211.  
  1212. procedure oDB.m(fnm:string;toPchar:pchar);     { field info as Memo }
  1213. var tPchar:Pchar;
  1214. begin
  1215.     sx_Select(Area);
  1216.     tPchar:=sx_GetMemo(StrPCopy(StrNull1,fnm),0);
  1217.     StrCopy(toPChar,tPchar);
  1218.     sx_MemDealloc(tPchar);
  1219. end;
  1220.  
  1221. function oDB.d(fnm:string):longint;    { date of form 04/15/95 }
  1222. begin
  1223.     sx_Select(Area);
  1224.     Result:=ctod(StrPas(sx_GetDateString(StrPCopy(StrNull1,fnm))))
  1225. end;
  1226.  
  1227. function oDB.ds(fnm:string):string;
  1228. var ll:longint;
  1229. begin
  1230.     sx_Select(Area);
  1231.     ll:=ctod(StrPas(sx_GetDateString(StrPCopy(StrNull1,fnm))));
  1232.     if ll>0 then Result:=dshyph(ll)
  1233.                     else Result:=space(8);
  1234. end;
  1235.  
  1236. function oDB.dj(fnm:string):longint; { date as Julian date}
  1237. begin
  1238.     sx_Select(Area);
  1239.     Result:=sx_GetDateJulian(StrPCopy(StrNull1,fnm))
  1240. end;
  1241.  
  1242. procedure oDB.ss(fnm:string;newval:string);
  1243. begin
  1244.     sx_Select(Area);
  1245.     sx_Replace(StrPCopy(StrNull1,fnm),r_char,StrPCopy(StrNull2,newval));
  1246. end;
  1247.  
  1248. procedure oDB.ll(fnm:string;newval:longint);
  1249. begin
  1250.     sx_Select(Area);
  1251.     sx_Replace(StrPCopy(StrNull1,fnm),r_long,@newval);
  1252. end;
  1253.  
  1254. procedure oDB.ii(fnm:string;newval:integer);
  1255. begin
  1256.     sx_Select(Area);
  1257.     sx_Replace(StrPCopy(StrNull1,fnm),r_integer,@newval);
  1258. end;
  1259.  
  1260. procedure oDB.bb(fnm:string;newval:boolean);
  1261. var ii:integer;
  1262. begin
  1263.     sx_Select(Area);
  1264.     if newval then ii:=1
  1265.                         else ii:=0;
  1266.     sx_Replace(StrPCopy(StrNull1,fnm),r_logical,@ii);
  1267. end;
  1268.  
  1269. procedure oDB.ff(fnm:string;newval:double);
  1270. begin
  1271.     sx_Select(Area);
  1272.     sx_Replace(StrPCopy(StrNull1,fnm),r_double,@newval);
  1273. end;
  1274.  
  1275. procedure oDB.nn(fnm:string;newval:double);
  1276. begin
  1277.     sx_Select(Area);
  1278.     sx_Replace(StrPCopy(StrNull1,fnm),r_double,@newval);
  1279. end;
  1280.  
  1281. procedure oDB.mm(fnm:string;newval:pchar);
  1282. var StrMemo:pchar;
  1283. begin
  1284.   StrMemo:=StrAlloc(MaxMemoSize);
  1285.     sx_Select(Area);
  1286.     StrCopy(StrMemo,newval);
  1287.     sx_Replace(StrPCopy(StrNull1,fnm),r_memo,StrMemo);
  1288.     StrDispose(StrMemo);
  1289. end;
  1290.  
  1291. procedure oDB.longs(fnm:string;tp:Pchar); { char fields>255 in length }
  1292. var tPchar:Pchar;
  1293. begin
  1294.     sx_Select(Area);
  1295.     tPchar:=sx_GetString(StrPCopy(StrNull1,fnm));
  1296.     StrCopy(tp,tPchar);
  1297.     sx_MemDealloc(tPchar);
  1298. end;
  1299.  
  1300. procedure oDB.longss(fnm:string;tp:Pchar); { Char fields>255 in length }
  1301. begin
  1302.     sx_Select(Area);
  1303.     sx_Replace(StrPCopy(StrNull1,fnm),r_char,tp);
  1304. end;
  1305.  
  1306. procedure oDB.dd(fnm:string;newval:longint);
  1307. var tt:string;
  1308. begin
  1309.     sx_Select(Area);
  1310.     { pass in longint of form 19950115, invalid dates force field to blank }
  1311.     { bug? in Delphi, must use defined var with StrPCopy, can't use
  1312.         function call as second arg, this won't work right, no error caused:
  1313.             StrPCopy(StrNull2,dtoc(newval) }
  1314.     tt:=dtoc(newval);
  1315.     sx_Replace(StrPCopy(StrNull1,fnm),r_datestr,StrPCopy(StrNull2,tt));
  1316. end;
  1317.  
  1318. function  oDB.GetFullRecord:string;
  1319. {return raw data, first 255 bytes only }
  1320. var tchar,dest:pchar;
  1321.     ii:longint;
  1322. begin
  1323.     sx_Select(Area);
  1324.   tchar:=stralloc(500);
  1325.   dest:=stralloc(500);
  1326.   sx_GetRecord(tchar);
  1327.   ii:=sx_RecSize;
  1328.   if ii>250 then ii:=250;
  1329.   strlcopy(dest,tchar,ii);
  1330.   result:=StrPas(dest);
  1331.   strdispose(tchar);
  1332.   strdispose(dest);
  1333. end;
  1334.  
  1335. function oDB.Alias:string;
  1336. begin
  1337.     sx_Select(Area);
  1338.     Result:=dbAlias;
  1339. end;
  1340.  
  1341. procedure oDB.Append;
  1342. begin
  1343.     sx_Select(Area);
  1344.     sx_AppendBlank;
  1345. end;
  1346.  
  1347. function oDB.Bof: boolean;
  1348. begin
  1349.     sx_Select(Area);
  1350.     result:=tf(sx_Bof);
  1351. end;
  1352.  
  1353. procedure oDB.GoBottom;
  1354. begin
  1355.     sx_Select(Area);
  1356.     sx_GoBottom;
  1357. end;
  1358.  
  1359. procedure oDB.Delete;  { mark record as deleted }
  1360. begin
  1361.     sx_Select(Area);
  1362.     sx_Delete;
  1363. end;
  1364.  
  1365. function oDB.Deleted: boolean; { status of deletion flag of record }
  1366. begin
  1367.     sx_Select(Area);
  1368.     Result:=tf(sx_Deleted);
  1369. end;
  1370.  
  1371. function oDB.Eof: boolean;
  1372. begin
  1373.     sx_Select(Area);
  1374.     result:=tf(sx_Eof);
  1375. end;
  1376.  
  1377. procedure oDB.Go(RecNo:longint);
  1378. begin
  1379.     sx_Select(Area);
  1380.     sx_Go(RecNo);
  1381. end;
  1382.  
  1383. function oDB.LastRec: longint;
  1384. begin
  1385.     sx_Select(Area);
  1386.     Result:=sx_Reccount;
  1387. end;
  1388.  
  1389. function oDB.LockList(var locklist:array of longint):integer;
  1390. var lcnt:integer;
  1391.         ptr:pointer;
  1392. begin
  1393.     sx_Select(Area);
  1394.     for lcnt:=0 to high(locklist) do locklist[lcnt]:=0;
  1395.     ptr:=addr(locklist);
  1396.     sx_DBRlockList(ptr);
  1397.     Result:=sx_LockCount;
  1398. end;
  1399.  
  1400. function oDB.Lock: boolean;   { try lock until succeeds }
  1401. var ii:integer;
  1402.         res:boolean;
  1403. begin
  1404.     sx_Select(Area);
  1405.     while true do begin
  1406.         res:=False;
  1407.         ii:=0;
  1408.         while (ii<2) and (not res) do  { notify after 4 seconds }
  1409.         begin
  1410.             DoEvents2;
  1411.             res:=tf(sx_rLock(sx_Recno));
  1412.             if not res then delay(2);
  1413.             pp(ii);
  1414.         end;
  1415.         if res then break else
  1416.             OKBox('Attempt To Lock Failed For '+AliasName+
  1417.                 ', Waiting, Please Check Around');
  1418.     end;
  1419.     Result:=res;
  1420. end;
  1421.  
  1422. function oDB.aLock: boolean;  { try a few times then return }
  1423. var ii:integer;
  1424.         res:boolean;
  1425. begin
  1426.     sx_Select(Area);
  1427.     ii:=0;
  1428.     res:=False;
  1429.     while (ii<2) and (not res) do  { timeout=2*2=4 seconds }
  1430.     begin
  1431.         res:=tf(sx_rLock(sx_Recno));
  1432.         if not res then delay(2);
  1433.         pp(ii);
  1434.     end;
  1435.     Result:=res;
  1436. end;
  1437.  
  1438. procedure oDB.Pack;
  1439. begin
  1440.     sx_Select(Area);
  1441.     sx_Pack;
  1442. end;
  1443.  
  1444. procedure oDB.Recall;  { unmark record as deleted }
  1445. begin
  1446.     sx_Select(Area);
  1447.     sx_Recall;
  1448. end;
  1449.  
  1450. procedure oDB.ReIndex;
  1451. begin
  1452.     sx_Select(Area);
  1453.     sx_ReIndex;
  1454. end;
  1455.  
  1456. function oDB.RecCount: longint;
  1457. begin
  1458.     sx_Select(Area);
  1459.     Result:=sx_RecCount;
  1460. end;
  1461.  
  1462. function oDB.RecNo: longint;
  1463. begin
  1464.     sx_Select(Area);
  1465.     Result:=sx_RecNo;
  1466. end;
  1467.  
  1468. function oDB.Seek(apattern:string): boolean;
  1469. begin
  1470.     sx_Select(Area);
  1471.     Result:=tf(sx_Seek(StrPCopy(StrNull1,apattern)));
  1472. end;
  1473.  
  1474. procedure oDB.SetOrder(ToIndex:integer);
  1475. begin
  1476.     sx_Select(Area);
  1477.     sx_SetOrder(ToIndex);
  1478.     CurOrder:=ToIndex;
  1479.     { if CurOrder<>sx_IndexOrd then
  1480.       OKBox('Index Order Not Set Correctly In '+AliasName); }
  1481. end;
  1482.  
  1483. procedure oDB.SetRelation(IntoAreaNum:integer;OnExpr:string);
  1484. begin
  1485.     sx_Select(Area);
  1486.     sx_SetRelation(IntoAreaNum,StrPCopy(StrNull1,OnExpr));
  1487. end;
  1488.  
  1489. procedure oDB.Skip;
  1490. begin
  1491.     sx_Select(Area);
  1492.     sx_Skip(1);
  1493. end;
  1494.  
  1495. procedure oDB.Skip2(ByCnt:integer);
  1496. begin
  1497.     sx_Select(Area);
  1498.     sx_Skip(ByCnt);
  1499. end;
  1500.  
  1501. procedure oDB.TagOrder(OrderByTag:String);
  1502. begin
  1503.     sx_Select(Area);
  1504.     sx_SetOrder(sx_TagArea(StrPCopy(StrNull1,OrderByTag)));
  1505. end;
  1506.  
  1507. procedure oDB.GoTop;
  1508. begin
  1509.     sx_Select(Area);
  1510.     sx_GoTop;
  1511. end;
  1512.  
  1513. procedure oDB.unLock;
  1514. begin
  1515.     sx_Select(Area);
  1516.     sx_Commit;
  1517.     sx_unLock(sx_Recno);
  1518. end;
  1519.  
  1520. procedure oDB.Zap;
  1521. begin
  1522.     sx_Select(Area);
  1523.     sx_Zap;
  1524. end;
  1525.  
  1526. procedure StartDBserver;
  1527. begin
  1528.  sx_SetHandles(MaxDBFs*2);
  1529.  sx_SetStringType(1);
  1530.  sx_SetDeleted(0);   { show records marked as deleted }
  1531.  StrNull1:=StrAlloc(255);
  1532.  StrNull2:=StrAlloc(255);
  1533.  DoEventsCnt:=0;
  1534. end;
  1535.  
  1536. end.
  1537.  
  1538.